home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
HPAVC
/
HPAVC CD-ROM.iso
/
BOI200P.ZIP
/
IOLIB.PAS
< prev
next >
Wrap
Pascal/Delphi Source File
|
1992-12-14
|
44KB
|
1,070 lines
{ $D-}
{$S-}
{$V-}
Unit IOLib;
{ Part of BBS Onliner Interface }
{ Copyright (C) 1990,1992 Andrew J. Mead }
{ All Rights Reserved. }
{ BBS Onliner Interface contains }
{ Async - low-level serial port communications interrupt handler }
{ BOIDecl - BOI standard declarations }
{ IOLib - standard console and port communications routines }
{ IOSupp - extended character code processing for IOLib.ReadPortKey }
{ GetCmBBS - command line parser and dropfile processing }
{ Support - common library functions and procedures }
{ DoorLib - information about door }
{ Key - registration key code shell }
{ Original version 7/1/90 }
{ Original release version 1.0 beta 9/5/90 }
{ Vers 1.01 9/19/90 /Q quiet local mode switch added }
{ Vers 1.01b 9/20/90 realname usage added, /A Remote Access defined }
{ Vers 1.02 9/22/90 RA access removed, /Q switch fixed }
{ Vers 1.03 9/23/90 /A play it Again switch added }
{ Vers 1.10 9/24/90 /2, /F, /M, /H, /5, /6 switches added }
{ Vers 1.11 9/29/90 beta version of /B locked baud rate }
{ Vers 1.12 10/ 1/90 /P switch added }
{ Vers 1.13 10/10/90 /N switch added }
{ Vers 1.14 10/22/90 /B switch fixed, carrier dectect routines added }
{ Vers 1.15 10/25/90 internal reorginizations, /K added }
{ Vers 1.16 11/ 9/90 /K fixed, F-9 abort added. }
{ Vers 1.17 12/ 1/90 internal reorginizations. }
{ Vers 1.17b12/ 5/90 /P fixed, /O implemented }
{ Vers 1.18 12/ 9/90 /O,/P verified /1,/3 implemented. }
{ Vers 1.20 12/10/90 Initial Public Release of BBS Onliner Interface. }
{ Vers 1.21 2/25/91 Minor cosmetic changes }
{ Vers 1.22 4/ 7/91 PortBackground bug fixed. }
{ Delay rewritten. }
{ Vers 1.23 4/13/91 initialization and IOExit added. }
{ Vers 1.24 5/11/92 ANSI routines modified, DisplayText added }
{ GetCommand command line parsing bug fixed. }
{ Vers 1.25 5/19/92 CRT unit support added... release version }
{ Vers 1.26 5/20/92 more fun }
{ Vers 1.27 6/11/92 registration keys added, DESQview support enhanced... }
{ Vers 1.28 6/13/92 }
{ Vers 1.29 6/15/92 timer interrupt added, Windoze, OS/2 awareness }
{ Vers 1.30 7/ 1/92 release version }
{ Vers 1.31 7/19/92 color routines optimized, TextAttr implemented }
{ Vers 1.32 7/24/92 Endgame bug fixed, Status Line handling improved }
{ Local function key handling improved (BOI > 3000 lines) }
{ Time remaining bug fixed }
{ Vers 1.33 8/ 4/92 Hall of Fame bug fixed, (ONE BBSCON) release version }
{ Vers 1.34 8/12/92 Another Hall of Fame bug fixed, release version }
{ Vers 1.35 8/16/92 /P fixed }
{ Vers 1.36 8/17/92 FOSSIL routines implemented, AVATAR routines added }
{ Vers 1.37 8/18/92 additional PCBoard support added }
{ Vers 1.38 8/26/92 minor code tightening, Minefield release }
{ Vers 1.39 11/12/92 variables renamed and standardized, commenting improved }
{ Vers 1.40 11/19/92 known bugs squashed, more drop file formats added }
{ Vers 2.00 12/14/92 Public Release of the BBS Onliner Interface }
{ }
{ To be done (short list): }
{ Activity logging (2.1?) }
{ Enhanced Error trapping and logging (2.1?) }
{ Natural language files support (2.2?) }
{ Config file script language (3.0) }
{ Record Locking (2.2-3.0) }
{ }
{ Long range possibilities }
{ object orientation (2.1...) }
{ add comm routines for multiport boards (need info) }
{ use of TP7 .DLLs for multinode play! (2.2...) }
{ take advantage of TP7 pchars and other new stuff (2.1) }
{ OS/2 version (either Claris Pascal or C/C++) (compiler availability) }
{ WinNT version (compiler availability) }
{ }
INTERFACE
Uses
BOIDecl,
Crt,
Dos;
{ Basic Functions }
Function MIN(a,b : word) : word;
Function MAX(a,b : word) : word;
Function MINL(a,b : longint) : longint;
Function MAXL(a,b : longint) : longint;
Function HEX(hexchar : char) : byte;
{* Internal Timing *}
Procedure TIMERSET(var basetime : longint);
Function GETTIMER(var basetime : longint; val : word) : boolean;
{* File Validation and Access *}
Function EXIST(thisfile : pathstr) : boolean;
Function VALID(thisfile : pathstr) : boolean;
Procedure NOTIFYSYSOP(nfile : pathstr);
Function OPENFILE(var f:file;fsize:word;fmode:byte;faccess:facctype) : word;
Function OPENTEXT(var f : text; fmode : byte; faccess : facctype) : word;
{ Output and String Functions }
Procedure SENDREMOTE(outstr : string);
Procedure SENDLOCAL(outstr : string);
Procedure SENDSTRING(outstr : string; docr : boolean);
Function INTSTR(val : longint; isize : byte) : string;
Function REALSTR(rval : real; rsize, rdec : byte) : string;
Function PADSTR(pstr : string; psize : byte) : string;
Procedure CLEANSTRING(var clean : string);
Procedure STRIPSTRING(var stripstr : string; stripset : charset);
Procedure GETSTRING(var gstr : string);
{ Housecleaning }
Function SETPORT : byte;
{ Display - Positional/Attribute }
Procedure SETLOCALGRAPHMODE(newmode : boi_grmode);
Procedure GOTOPORTXY(x,y : byte);
Procedure PORTCOLOR(acolor, bcolor : byte);
Procedure TEXTPORTCOLOR(color : byte);
Procedure PORTBACKGROUND(color: byte);
Procedure GETTEXTATTR(var attribs : word);
Procedure SETTEXTATTR(attribs : word);
Procedure CHANGECOLOR(attribs : word);
Procedure UPDATESTATLINE;
Procedure CLRPORTSCR;
Procedure CLRPORTEOL;
Procedure PORTWINDOW(x1,y1,x2,y2 : byte);
Procedure PORTCOLUMNONE;
{ Input Functions }
Function READPORTKEY : char;
Function PORTKEYPRESSED : boolean;
Procedure CLEARBUFFERS;
{ Advanced Cursor functions }
Procedure SETPORTXY;
Procedure RESETPORTXY;
{ Timeout procedure }
Function LEFTTIME : integer;
Procedure DOTIMEOUT(ringbell : boolean);
IMPLEMENTATION
Uses
IOSupp,
Async;
Const
null = #$00;
bell = #$07;
ctrla = #$01; {AVATAR attrib}
ctrlb = #$02; {AVATAR blink}
ctrle = #$05;
ctrlg = #$07; {AVATAR ClrEOL}
ctrlh = #$08; {AVATAR GotoXY}
ctrll = #$0C;
ctrlv = #$16;
ctrlw = #$17; {AVATAR Switch Window}
ctrly = #$19; {AVATAR repeat}
esc = #$1B;
io_trylim = 10; { file locked retry limit }
io_basex : byte = 1; { internal cursor positioning variables }
io_basey : byte = 1;
io_endx : byte = 80;
io_endy : byte = 24;
io_tempx : byte = 1;
io_tempy : byte = 1;
io_l_avwin : byte = $00; { active AVATAR/1 window (local) }
io_r_avwin : byte = $00; { active AVATAR/1 window (remote) }
Var
io_regs : registers; { general purpose temporary registers }
io_keyregs : registers;
io_workstr : string; { general purpose temporary variables }
io_tempbyte : byte;
io_tempchar : char;
io_l_textattr : byte; { current local text attributes }
io_r_textattr : byte; { current remote text attributes }
Function MIN(a, b : word) : word; { returns the minimum of two Word values }
begin {* fMin *}
if a < b then Min := a else Min := b
end; {* fMin *}
Function MAX(a, b : word) : word; { returns the maximum of two Word values }
begin {* fMax *}
if a > b then Max := a else Max := b
end; {* fMax *}
Function MINL(a, b : longint) : longint; { returns smaller longit value }
begin {* fMinL *}
if a < b then MinL := a else MinL := b
end; {* fMinL *}
Function MAXL(a, b : longint) : longint; { returns larger longit value }
begin {* fMaxL *}
if a < b then MaxL := a else MaxL := b
end; {* fMaxL *}
Function HEX(hexchar : char) : byte; { converts hex character into byte }
var
hexbyte : byte absolute hexchar;
begin {* fHex *}
if hexchar in ['0'..'9'] then Hex := hexbyte AND $0F
else Hex := (hexbyte AND $0F) + $09
end; {* fHex *}
Procedure TIMERSET( { used with GetTimer for elapsed time routines }
var basetime : longint); { variable to assign current time value to }
begin {* TimerSet *}
basetime := boi_timer;
end; {* TimerSet *}
Function GETTIMER( { true if "val" seconds since TimerSet(basetime) }
var basetime : longint; { variable assigned by TimerSet }
val : word) : boolean; { target number of seconds elapsed }
begin {* GetTimer *}
GetTimer := (boi_timer - basetime) / 18.2 > val
end; {* GetTimer *}
Function OPENFILE( { open an untyped file, returns IOResult }
var f : file; { file handle }
fsize : word; { record size }
fmode : byte; { file sharing mode }
faccess : facctype) : word; { file opening mode }
const
busy = 5; { IOResult DOS file busy return code }
var
result : word; { result of attempt to open file }
tries : byte; { locked file retries count }
begin {* fOpenFile *}
filemode := fmode;
if not dos_share then filemode := filemode AND $07;
tries := 0;
{$I-} { we'll do our own checking }
repeat
begin
Inc(tries);
case faccess of { attempt to open file }
treset : Reset(f,fsize);
trewrite :
begin
Rewrite(f,fsize);
Close(f);
Reset(f,fsize)
end
end;
result := IOResult; { was it successful? }
if result = busy then if not in_dos^ then BOI_Wait
{ if busy, then give up rest of timer tick }
end
until (result <> busy) or ((tries >= io_trylim) and (result = busy));
{$I+}
OpenFile := result
end; {* fOpenFile *}
Function OPENTEXT( { open an untyped file, returns IOResult }
var f : text; { file handle }
fmode : byte; { file sharing mode }
faccess : facctype) : word; { file opening mode }
const
busy = 5; { IOResult DOS file busy return code }
var
result : word; { result of attempt to open file }
tries : byte;
begin {* fOpenText *}
filemode := fmode;
if not dos_share then filemode := filemode AND $07;
tries := 0;
{$I-} { we'll do the error checking }
repeat
begin
Inc(tries); { try to open the file }
case faccess of
treset : Reset(f);
trewrite : Rewrite(f);
tappend : Append(f)
end;
result := IOResult; { did it work? }
if result = busy then if not in_dos^ then BOI_Wait
{ if it was busy, then wait }
end
until (result <> busy) or ((tries >= io_trylim) and (result = busy));
{$I+}
OpenText := result
end; {* fOpenText *}
Procedure NOTIFYSYSOP( { file not found! Tell user to bother SysOp }
nfile : pathstr); { file that wasn't found }
begin {* NotifySysOp *}
PortWindow(1,1,80,boi_pagelength);
ClrPortScr;
PortColor(cyan,lightgray);
PortBackground(black);
SendString('Unable to find the file : ',false);
TextPortColor(white);
SendString(nfile,true);
PortColor(cyan,lightgray);
SendString('Please notify SysOp. Press almost any key to continue.',false);
ClearBuffers;
io_tempchar := ReadPortKey
end; {* NotifySysOp *}
Function EXIST( { Check for files existence }
thisfile : pathstr) : boolean; { filespec for file to check }
var
afile : file; { temporary file handle }
isfile : boolean; { temporary result holder }
begin {* fExist *}
Assign(afile,thisfile);
isfile := OpenFile(afile,1,denynone+read_only,treset) = 0;
if isfile then Close(afile);
Exist := isfile
end; {* fExist *}
Function VALID( { Check filespec for validity }
thisfile : pathstr) : boolean; { filespec to check }
var
afile : file; { temporary file handle }
isgood : boolean; { temporary result holder }
begin {* fValid *}
if not Exist(thisfile) then { if the file Exists, then it is Valid }
begin
Assign(afile,thisfile);
isgood := OpenFile(afile,1,denynone+read_only,trewrite) in [0,163];
if isgood then
begin
Close(afile); { if the filespec is Valid, but it did }
Erase(afile) { not Exist, we just created one!!! }
end;
Valid := isgood
end
else Valid := true
end; {* fValid *}
{ this procedure should really only be called by SendString }
Procedure SENDREMOTE( { send character(s) to remote with wait }
outstr : string); { string to send }
begin {* SendRemote *}
for io_tempbyte := 1 to Length(outstr) do SendChar(outstr[io_tempbyte])
end; {* SendRemote *}
{ this procedure should really only be called by SendString }
Procedure SENDLOCAL( { send character(s) to local console }
outstr : string); { string to send }
begin {* SendLocal *}
Write(outstr)
end; {* SendLocal *}
Procedure SENDSTRING( { general output procedure }
outstr : string; { string to output }
docr : boolean); { output newline indicator }
begin {* SendString *}
if docr then outstr := outstr + #$0D#$0A; { append CR/LF }
if not boi_local then SendRemote(outstr);
if boi_local or boi_echo then
begin
{ if quiet mode, then strip ^Gs (bells) from output string }
if boi_quiet then for io_tempbyte := Length(outstr) downto 1 do
if outstr[io_tempbyte] = bell then Delete(outstr,io_tempbyte,1);
SendLocal(outstr)
end
end; {* SendString *}
Function INTSTR( { takes integer value and returns string }
val : longint; { value to convert }
isize : byte) : string; { size of output string }
var
ist : string; { temporary string variable }
begin {* fIntStr *}
Str(val:isize,ist);
IntStr := ist
end; {* fIntStr *}
Function REALSTR( { takes real value and returns string }
rval : real; { value to convert }
rsize : byte; { size of output string }
rdec : byte) : string; { number of decimal spaces in output string }
var
ist : string; { temporary string variable }
begin {* fRealStr *}
Str(rval:rsize:rdec,ist);
RealStr := ist
end; {* fRealStr *}
Function PADSTR( { pad text string out to psize spaces }
pstr : string; { string to right justify }
psize : byte) : string; { size of output string }
var
tstr : string; { temporary string variable }
begin {* fPadStr *}
if Length(pstr) > psize then PadStr := pstr
else
begin
FillChar(tstr[1],psize,32);
tstr[0] := Chr(psize);
Move(pstr[1],tstr[psize - Length(pstr) + 1],Length(pstr));
PadStr := tstr
end
end; {* fPadStr *}
Procedure CLEANSTRING( { remove whitespace from front and back of string }
var clean : string); { string to clean }
begin {* CleanString *}
while (Length(clean) > 0) and (clean[1] = ' ') do
Delete(clean,1,1);
while (Length(clean) > 0) and (clean[Length(clean)] = ' ') do
Dec(clean[0])
end; {* CleanString *}
Procedure STRIPSTRING( { remove specified characters from string }
var stripstr : string; { string to strip }
stripset : charset); { characters to remove from string }
var
sloop : byte;
begin {* StripString *}
for sloop := Length(stripstr) downto 1 do
if stripstr[sloop] in stripset then
Delete(stripstr,sloop,1)
end; {* StripString *}
Function LOCALKEYPRESSED : boolean;
{ indicates whether or not key on local keyboard has been pressed }
begin {* fLocalKeyPressed *}
if KeyPressed then with io_keyregs do
begin
repeat { remove all function keys from head of local buffer }
begin
AH := $01; { peak at next character in buffer }
Intr($16,io_keyregs);
if AL = $00 then { if it is a function key then... }
begin
AH := $00; { get next character from buffer }
Intr($16,io_keyregs);
CheckSecondKey(Chr(AH)) { send it off for processing }
end
end
until (not KeyPressed) or (AL <> $00);
LocalKeyPressed := (AL <> $00)
end
else LocalKeyPressed := false { local buffer is empty }
end; {* fLocalKeyPressed *}
Function READPORTKEY : char; { returns (with wait) input character }
var
rkey : char; { input character }
begin {* fReadPortKey *}
boi_stall := 0; { reset inactivity timeout value }
if boi_local then { if in local mode, then use this simpler routine }
begin
repeat BOI_Wait until LocalKeyPressed;
rkey := ReadKey
end
else
begin
while not (CharReady or LocalKeyPressed or (boi_stall >= 1092) or
not Carrier) do if not in_dos^ then
BOI_Wait;
if not (LocalKeyPressed or CharReady) and Carrier and
(boi_stall >= 1092) then
begin { no activity for one minute }
SendString(bell,false); { send bell to wake up user }
while not (CharReady or LocalKeyPressed or (boi_stall >= 2184) or
not Carrier) do if not in_dos^ then
BOI_Wait
end;
if not Carrier then DoTimeOut(false) { see if user dropped carrier }
else if not (LocalKeyPressed or CharReady) and
(boi_stall >= 2184) then DoTimeOut(true) { two minutes-no activity }
else if CharReady then rkey := ReadBuffer
else if LocalKeyPressed then rkey := ReadKey
end;
ReadPortKey := rkey;
boi_stall := 0 { reset inactivity timeout value }
end; {* fReadPortKey *}
Function PORTKEYPRESSED : boolean; { is there input waiting? }
begin {* fPortKeyPressed *}
if boi_local then PortKeyPressed := LocalKeyPressed
else PortKeyPressed := LocalKeyPressed or CharReady
end; {* fPortKeyPressed *}
Procedure CLEARBUFFERS; { blank out local and remote input buffers }
var
cbchar : char; { temporary input character }
begin {* ClearBuffers *}
while LocalKeyPressed do cbchar := ReadKey;
if not boi_local then ClearInBuffer
end; {* ClearBuffers *}
Procedure GETSTRING( { return string of input characters up to next newline }
var gstr : string); { string to return }
var
gchar : char; { temporary input character }
begin {* GetString *}
gstr := '';
repeat
begin
if boi_nextchar = #$00 then
gchar := ReadPortKey { get character }
else
begin
gchar := boi_nextchar;
boi_nextchar := #$00
end;
if gchar in [#32..#126] then { test for validity }
begin
gstr := gstr + gchar; { append character to string }
SendString(gchar,false) { echo character back out }
end
else if (gchar = #8) and (Length(gstr) > 0) then
begin { if backspace and string exists... }
Delete(gstr,Length(gstr),1);
SendString(gchar + ' ' + gchar,false)
end
end
until gchar = #13; { repeat until newline }
SendString('',true) { echo newline }
end; {* GetString *}
{ This function should only be called by GetCmBBS }
Function SETPORT : byte; { returns $00 if successful }
const
portset : boolean = false;
begin {* fSetPort *}
if portset then SetPort := $FF { return $FF if procedure already called }
else
begin
portset := true;
if boi_local then SetPort := $00 { local mode needs no initializing }
else SetPort := IntInit { call Async.IntInit }
end
end; {* fSetPort *}
{ this should be used to set or change boi_l_grmode }
Procedure SETLOCALGRAPHMODE( { sets up local console graphics mode }
newmode : boi_grmode);
begin {* SetLocalGraphMode *}
boi_l_grmode := newmode;
if boi_l_grmode = gr_tpcrt then
directvideo := boi_tasker in [notask,dos5]
{ if no multi-tasker present, use direct screen writes }
{ otherwise use BIOS routines for local console }
else
begin
directvideo := false; { send output through CONsole driver }
Assign(output,'');
ReWrite(output);
if boi_l_grmode = gr_avt then { additional AVATAR/1 set up }
begin
io_l_avwin := $00; { current AVATAR window }
checkbreak := false;
SendLocal(ctrlv + '=R'); { define current AVATAR screen }
SendLocal(ctrlv + ctrlv + Chr($FF) + Chr($03) + #25#01#25#80)
end
end
end; {* SetLocalGraphMode *}
Function AVSTR(value : byte) : string;
begin
if value <> value then AVStr := #10 + Chr(value)
else AVStr := Chr(value)
end;
Procedure GOTOPORTXY( { set current position }
x : byte; { column to move cursor to (1..80) }
y : byte); { row to move cursor to (1..25) }
begin {* GotoPortXY *}
if not boi_local then case boi_r_grmode of { position remote cursor }
gr_ansi : SendRemote(esc + '[' + IntStr(y + io_basey - 1,0) + ';' +
IntStr(x + io_basex - 1,0) + 'H');
gr_avt : SendRemote(ctrlv + ctrlh + Chr(y + io_basey - 1) +
Chr(x + io_basex - 1))
end;
if boi_local or boi_echo then case boi_l_grmode of {position local cursor}
gr_ansi : SendLocal(esc + '[' + IntStr(y + io_basey - 1,0) + ';' +
IntStr(x + io_basex - 1,0) + 'H');
gr_avt : SendLocal(ctrlv + ctrlh + AvStr(y + io_basey - 1) +
AvStr(x + io_basex - 1));
gr_tpcrt : GotoXY(x,y)
end
end; {* GotoPortXY *}
Procedure REMOTECOLOR( { internal, sets remote text attributes }
color : byte); { new remote attributes }
begin {* RemoteColor *}
color := color AND $8F; { blink must be set seperately }
{ only change color if new color is not current color }
if (io_r_textattr AND $8F <> color) then case boi_r_grmode of
gr_ansi : { ANSI processing }
begin
if color > $87 then { color is intense and blinking }
SendRemote(esc+'['+IntStr(boi_ansiarr[color],0)+';01;05m')
else if color > $7F then { color is intense }
SendRemote(esc+'[00;'+IntStr(boi_ansiarr[color],0)+';05m')
else if color > $07 then { color is blinking }
SendRemote(esc+'[00;'+IntStr(boi_ansiarr[color],0)+';01m')
else
SendRemote(esc+'[00;'+IntStr(boi_ansiarr[color],0)+'m');
if io_r_textattr AND $70 <> $00 then { change background color }
PortBackground((io_r_textattr AND $70) SHR 4)
end;
gr_avt : { AVATAR processing }
begin
if color AND $80 = $80 then SendRemote(ctrlv + ctrlb);
color := color AND $7F;
SendRemote(ctrlv + ctrla + Chr(color))
end
end;
io_r_textattr := (io_r_textattr AND $70) OR color {update text attribute}
end; {* RemoteColor *}
Procedure LOCALCOLOR( { internal, sets local console text attributes }
color : byte); { new text attributes }
begin {* LocalColor *}
color := color AND $8F;
{ only change color if new color is not same as old color }
if (boi_local or boi_echo) and (io_l_textattr AND $8F <> color) then
case boi_l_grmode of
gr_ansi : { ANSI processing }
begin
if color > $87 then { color is intense and blinking }
SendLocal(esc+'['+IntStr(boi_ansiarr[color],0)+';01;05m')
else if color > $7F then { color is intense }
SendLocal(esc+'[00;'+IntStr(boi_ansiarr[color],0)+';05m')
else if color > $07 then { color is blinking }
SendLocal(esc+'[00;'+IntStr(boi_ansiarr[color],0)+';01m')
else
SendLocal(esc+'[00;'+IntStr(boi_ansiarr[color],0)+'m');
if io_l_textattr AND $70 <> $00 then { change background color }
PortBackground((io_l_textattr AND $70) SHR 4)
end;
gr_avt : { AVATAR processing }
begin
if color AND $80 = $80 then SendLocal(ctrlv + ctrlb);
color := color AND $7F;
SendLocal(ctrlv + ctrla + Chr(color))
end;
gr_tpcrt : TextColor(color) { direct video processing }
end;
io_l_textattr := (io_l_textattr AND $70) OR color {update text attribute}
end; {* LocalColor *}
Procedure PORTCOLOR( { change current color conditional on color mode }
acolor : byte; { color to be if color mode }
bcolor : byte); { color to be if black/white mode }
begin {* PortColor *}
if not boi_local then { change remote color }
if boi_r_color then RemoteColor(acolor)
else RemoteColor(bcolor);
if boi_local or boi_echo then { change local color }
if boi_l_color then LocalColor(acolor)
else LocalColor(bcolor);
end; {* PortColor *}
Procedure TEXTPORTCOLOR( { change current color absolute }
color : byte); { color to change to }
begin {* TextPortColor *}
if not boi_local then RemoteColor(color); { change remote color }
if boi_local or boi_echo then LocalColor(color) { change local color }
end; {* TextPortColor *}
Procedure PORTBACKGROUND( { change text background color }
color : byte); { color for background to be }
begin {* PortBackground *}
color := color AND $07;
if not boi_local then { change remote background color }
begin
if (color SHL 4) <> (io_r_textattr AND $70) then case boi_r_grmode of
gr_ansi : if color in [0..7] then {must be valid background color}
SendRemote(esc + '[' + IntStr(boi_ansiarr[color] + 10,0) + 'm');
gr_avt :
SendRemote(ctrlv + ctrla + Chr((io_r_textattr AND $0F) OR
(color SHL 4)))
end;
io_r_textattr := (io_r_textattr AND $8F) OR (color SHL 4)
end;
if boi_local or boi_echo then { change local background color }
begin
if (color SHL 4) <> (io_l_textattr AND $70) then case boi_l_grmode of
gr_ansi : if color in [0..7] then {must be valid background color}
SendLocal(esc + '[' + IntStr(boi_ansiarr[color] + 10,0) + 'm');
gr_avt :
SendLocal(ctrlv + ctrla + Chr((io_l_textattr AND $0F) OR
(color SHL 4)));
gr_tpcrt : TextBackground(color)
end;
io_l_textattr := (io_l_textattr AND $8F) OR (color SHL 4)
end
end; {* PortBackground *}
Type
attype = array [0..1] of byte;
Procedure GETTEXTATTR( { get current text attributes }
var attribs : word);
var
atsplit : attype absolute attribs;
begin {* GetTextAttr *}
atsplit[0] := io_r_textattr;
atsplit[1] := io_l_textattr
end; {* GetTextAttr *}
Procedure SETTEXTATTR( { set text attributes (does NOT change color) }
attribs : word);
var
atsplit : attype absolute attribs;
begin {* SetTextAttr *}
io_r_textattr := atsplit[0];
io_l_textattr := atsplit[1]
end; {* SetTextAttr *}
Procedure CHANGECOLOR( { change color (by text attributes) }
attribs : word);
var
atsplit : attype absolute attribs;
{ this is usually used as a restore with data from GetTextAttr }
begin {* ChangeColor *}
if not boi_local then
begin
RemoteColor(atsplit[0]);
TextBackground((atsplit[0] AND $70) SHR 4)
end;
LocalColor(atsplit[1]);
if boi_local or boi_echo then TextBackground((atsplit[1] AND $70) SHR 4)
end; {* ChangeColor *}
Procedure UPDATESTATLINE; { updates user status line on local console }
var
cloop : byte;
tempmin : word;
tempmax : word;
tempstr : string;
oldattr : word;
begin {* UpdateStatLine *}
if not boi_local then
begin
{ initialize stat line }
FillChar(io_workstr,SizeOf(io_workstr),' ');
io_workstr := '[F2] toggle ';
{ add player's name to stat line }
if boi_usename then io_workstr := io_workstr + boi_username
else io_workstr := io_workstr + 'Player Name Unknown';
if boi_usereal then io_workstr := io_workstr + ', ' + boi_realname;
{ set stat line to 79 characters }
io_workstr[0] := chr(79);
case boi_statmode of
sm_time : if boi_usetime then
begin { show time remaining in 1/10ths of minutes }
tempstr := 'Time: ' + tempstr;
Move(tempstr[1],io_workstr[68],12)
end;
sm_help1 : { show help line }
begin
io_workstr :=
'[F2] toggle [F7] less time [F8] more time [F9] hang up [F10] exit';
Str(boi_ticks/1092:6:1,tempstr);
io_workstr := io_workstr + tempstr
end;
sm_comm : { show current remote communications parameters }
Move(boi_cstr[1],io_workstr[80 - Length(boi_cstr)],
Length(boi_cstr));
sm_vid : { show current remote video mode }
begin
tempstr := ' Remote Video: ';
case boi_r_grmode of
gr_ascii : tempstr := tempstr + 'ASCII';
gr_ansi : tempstr := tempstr + 'ANSI';
gr_avt : tempstr := tempstr + 'AVATAR';
else tempstr := tempstr + 'Unknown';
end;
Move(tempstr[1],io_workstr[80-Length(tempstr)],Length(tempstr))
end
end;
if boi_l_grmode in [gr_ansi,gr_tpcrt] then
begin { save current text attribute (windowing saves AVATAR's) }
GetTextAttr(oldattr);
ChangeColor((oldattr AND $00FF) OR $0E00)
end;
case boi_l_grmode of
gr_ansi : { ANSI processing }
begin
SendLocal(esc + '[s'); { SetPortXY }
SendLocal(esc+'[25;1H'); { GotoPortXY(1,25) }
SendLocal(io_workstr);
SendLocal(esc + '[u') { ResetPortXY }
end;
gr_avt : { AVATAR processing }
begin
SendLocal(ctrlv + ctrlw + Chr($FF)); { declare new window }
SendLocal(ctrll); { set attributes }
SendLocal(io_workstr);
SendLocal(ctrlv + ctrlw + Chr(io_l_avwin)) { goto old window }
end;
gr_tpcrt : { CRT processing }
begin
io_tempx := WhereX; { save current window settings }
io_tempy := WhereY;
tempmin := windmin;
tempmax := windmax;
Window(1,1,80,25);
GotoXY(1,25);
SendLocal(io_workstr);
windmin := tempmin; { restore old window settings }
windmax := tempmax;
GotoXY(io_tempx,io_tempy)
end
end;
if boi_l_grmode in [gr_ansi,gr_tpcrt] then { restore old attributes }
ChangeColor(oldattr)
end;
boi_stime := boi_timer { update stat line time keeper }
end; {* UpdateStatLine *}
Procedure CLRPORTSCR; { clears current window }
var
cloop : byte; { temporary looping variable }
begin {* ClrPortScr *}
if not boi_local then case boi_r_grmode of { clear remote screen }
gr_ascii : SendRemote(#12); { ASCII mode / formfeed }
gr_ansi : { ANSI processing }
begin
if (io_basey = 1) and (io_endy >= boi_pagelength) then
{ if full window, clearing screen is simple }
SendRemote(esc + '[2J')
else for cloop := 0 to io_endy - io_basey do
begin { clear each line in current window }
SendRemote(esc + '[' + IntStr(io_endy - cloop,0) + ';1H');
if cloop < 24 then SendRemote(esc + '[K')
{ if not bottom of screen clear EOL sequence is fine }
else SendRemote(PadStr('',79))
{ some ANSI drivers scroll window if bottom right character }
{ is manipulated in any way }
end
end;
gr_avt : { AVATAR processing }
begin
SendRemote(ctrlv + ctrlh + Chr(io_basey) + Chr(io_basex));
SendRemote(ctrlv + ctrll + Chr(io_r_textattr AND $7F) +
Chr(io_endy - io_basey + 1) + Chr(io_endx - io_basex + 1))
end
end;
if boi_local or boi_echo then { clear local screen }
begin
case boi_l_grmode of
gr_ascii : SendLocal(#12); { ASCII mode / formfeed }
gr_ansi : { ANSI processing }
begin
if (io_basey = 1) and (io_endy >= boi_pagelength) then
{ clearing full window is easy and quick }
SendLocal(esc + '[2J')
else for cloop := 0 to io_endy - io_basey do
begin { clear each individual line }
SendLocal(esc + '[' + IntStr(io_endy-cloop,0) + ';1H');
if io_endy-cloop < 24 then SendLocal(esc + '[K')
{ if not bottom of screen clear EOL sequence is fine }
else SendLocal(PadStr('',79))
{ some ANSI drivers scroll window if bottom right }
{ character is manipulated in any way }
end
end;
gr_avt : { AVATAR processing }
begin
SendLocal(ctrlv + ctrlh + AvStr(io_basey) + AvStr(io_basex));
SendLocal(ctrlv + ctrll + Chr(io_l_textattr AND $7F) +
Chr(io_endy - io_basey + 1) + Chr(io_endx - io_basex + 1))
end;
gr_tpcrt : ClrScr { CRT processing }
end;
if boi_usename and (not boi_local) and { update Status Line? }
(((boi_l_grmode = gr_ansi) and (io_endy >= boi_pagelength)) or
((boi_l_grmode = gr_tpcrt) and (Hi(windmax) >= boi_pagelength))) then
UpdateStatLine
end
end; {* ClrPortScr *}
Procedure CLRPORTEOL; { clears current line from cursor to right edge }
begin {* ClrPortEOL *}
if not boi_local then case boi_r_grmode of { clear remote line }
gr_ansi : SendRemote(esc + '[K');
gr_avt : SendRemote(ctrlv + ctrlg)
end;
if boi_local or boi_echo then case boi_l_grmode of { clear local line }
gr_ansi : SendLocal(esc+'[K');
gr_avt : SendLocal(ctrlv + ctrlg);
gr_tpcrt : ClrEOL
end
end; {* ClrPortEOL *}
Procedure PORTWINDOW( { declare active window }
x1 : byte; { leftmost column (1..x2) }
y1 : byte; { topmost line (1..y1) }
x2 : byte; { rightmost line (x1..80) }
y2 : byte); { bottom line (y1..pagelength) }
begin {* PortWindow *}
{ use internal windowing routines for most situations }
if ((boi_echo or boi_local) and (boi_l_grmode in [gr_ansi,gr_avt])) or
((not boi_local) and (boi_r_grmode in [gr_ansi,gr_avt])) then
begin { set screen parameters }
io_basex := x1;
io_basey := y1;
io_endx := Max(x1,Min(80,x2));
io_endy := Max(y1,Min(24,y2))
end;
{ if local mode uses direct video, then use Borland's windowing locally }
if (boi_local or boi_echo) and (boi_l_grmode = gr_tpcrt) then
Window(x1,y1,x2,Min(25,y2));
GotoPortXY(1,1)
end; {* PortWindow *}
Procedure PORTCOLUMNONE; { puts cursor on left side of screen on current line }
begin {* PortColumnOne *}
if not boi_local then case boi_r_grmode of { move remote cursor }
gr_ansi : SendRemote(esc+'[79D');
gr_avt : SendRemote(ctrlv + ctrly + Chr(2) + ctrlv + ctrle + Chr(79))
end;
if boi_local or boi_echo then case boi_l_grmode of { move local cursor }
gr_ansi : SendLocal(esc+'[79D');
gr_avt : SendLocal(ctrlv + ctrly + Chr(2) + ctrlv + ctrle + Chr(79));
gr_tpcrt : GotoXY(1,WhereY)
end
end; {* PortColumnOne *}
Procedure SETPORTXY; { saves current cursor position }
begin {* SetPortXY *}
if not boi_local then case boi_r_grmode of { save remote cursor }
gr_ansi : SendRemote(esc+'[s'); { ANSI processing }
gr_avt : { AVATAR processing }
begin
Inc(io_r_avwin); { declare new AVATAR window }
SendRemote(ctrlv + ctrlv + Chr(io_r_avwin) +
Chr(io_r_textattr) + #01#01#25#80);
SendRemote(ctrlv + ctrlw + Chr(io_r_avwin)) {switch to new window}
end
end;
if boi_local or boi_echo then case boi_l_grmode of { save local cursor }
gr_ansi : SendLocal(esc+'[s'); { ANSI processing }
gr_avt : { AVATAR processing }
begin
Inc(io_l_avwin); { declare new AVATAR window }
SendLocal(ctrlv + ctrlv + Chr(io_l_avwin) +
Chr(io_l_textattr) + #01#01#25#80);
SendLocal(ctrlv + ctrlw + Chr(io_l_avwin)) {switch to new window}
end;
gr_tpcrt : { CRT processing }
begin
io_tempx := WhereX; { store cursor postion }
io_tempy := WhereY
end
end
end; {* SetPortXY *}
{ this should only be used after a call to SetPortXY }
Procedure RESETPORTXY; { restore saved cursor position }
begin {* ResetPortXY *}
if not boi_local then case boi_r_grmode of { restore remote cursor }
gr_ansi : SendRemote(esc + '[u'); { ANSI processing }
gr_avt : if io_r_avwin > $00 then { AVATAR processing }
begin
Dec(io_r_avwin); { retreat to previous AVATAR window }
SendRemote(ctrlv + ctrlw + Chr(io_r_avwin))
end
end;
if boi_local or boi_echo then case boi_l_grmode of {restore local cursor}
gr_ansi : SendLocal(esc + '[u'); { ANSI processing }
gr_avt : if io_l_avwin > $00 then { AVATAR processing }
begin
Dec(io_l_avwin); { retreat to previous AVATAR window }
SendLocal(ctrlv + ctrlw + Chr(io_l_avwin))
end;
gr_tpcrt : GotoXY(io_tempx,io_tempy) { direct video processing }
end
end; {* ResetPortXY *}
Procedure DOTIMEOUT( { BOI has timed out do to inactivity }
ringbell : boolean); { if not Async timout, send ^G (bell) }
begin {* DoTimeOut *}
if ringbell then SendString(bell,true);
ClrScr;
SendLocal('Program timeout. ');
if Carrier then SendLocal('No input for 2 minutes.'+#$0D#$0A)
else SendLocal('Carrier Dropped.'+#$0D#$0A);
SendLocal('Returning control to BBS.'+#$0D#$0A);
Halt { Crank up the Exit Procedure chain }
end; {* DoTimeOut *}
Function LEFTTIME : integer; { returns number of minutes left to play }
begin {* fLeftTime *}
if boi_ticks <= 0 then { time has expired }
begin
boi_timeover := true;
LeftTime := -1
end
else LeftTime := longint(boi_ticks) div 1092 { convert to minutes }
end; {* fLeftTime *}
Var
io_nextexit : pointer; { pointer to hold address of next Exit procedure }
io_oldtextattr : word; { hold initial text attributes of local console }
{$F+}
Procedure IOEXIT;
begin {* IOExit *} { unit exit code }
exitproc := io_nextexit; { reset chain of Exit Procedures }
textattr := io_oldtextattr; { reset original text attributes }
Window(1,1,80,25);
GotoXY(1,25); { put cursor at bottom of the screen }
ClrEOL;
NormVideo
end; {* IOExit *}
{$F-}
begin {* uIOLib *} { unit initialization code }
directvideo := (boi_tasker in [notask,dos5]);
io_oldtextattr := textattr; { store current local text attributes }
io_l_textattr := textattr; { set local text attribute variable }
io_r_textattr := textattr; { set remote text attribute variable }
io_nextexit := exitproc; { save current Exit Procedure chain }
exitproc := @IOExit { add IOLib to Exit Procedure chain }
end. {* uIOLib *}